Cobra Utilities for Doom & Doom II/Cobra Utilities For Doom & Doom II - Disc 2.iso/files/program/dhtk100/wad.pas

Pascal/Delphi Source File | 1994-05-26 | 7.9 KB | 325 lines

{****************************************************************************
*                      The DOOM Hacker's Tool Kit                           *
*****************************************************************************
* Unit:       WAD                                                              *
* Purpose: Loading WAD File directory and much more                         *
* Date:    4/28/94                                                          *
* Author:  Joshua Jackson        Internet: [e-mail]           *
****************************************************************************}

{$O+,F+}
unit wad;

interface

uses WadDecl;

type    PWadDirectory=^TWadDirectory;
        TWadDirectory=object
            WadName        :array[1..9] of char;
            WadFile        :file;
            WadID            :array[1..4] of char;
            DirEntries    :longint;
            DirStart        :longint;
            DirEntry     :PWADDirList;
            Constructor Init(WadFileName:String);
            Procedure DisplayWadDir;
            Function FindObject(ObjName:ObjNameStr):word;
            Procedure SetWadPalette(PlayPalNum:integer);
            Procedure RestorePalette;
            Destructor Done;
        end;

Function WadResultMsg(ErrNum:byte):string;

Const TerminateOnWadError:boolean=True;
        WadResult        :Integer = 0;
        wrOk                = 00;
        wrInvalidFile    = 01;
        wrMaxEntries    = 02;
        wrNoObject        = 03;
        wrNoSound        = 04;
        wrBadImageSize = 05;
        wrNoPicture        = 06;
        wrNoPalette        = 07;
        wrNoFile            = 08;
        ShowInit            :boolean=False;
        WadPaletteIsSet:Boolean=false;

implementation

uses crt,windos,dos;

var    OldPalette:array[1..768] of byte;

Function TWadDirectory.FindObject(ObjName:ObjNameStr):word;

    var    t,x:integer;
            TempName:ObjNameStr;

    begin
        for t:=8 downto 1 do begin
            if ObjName[t] = ' ' then
                ObjName[t]:= #0;
            ObjName[t]:=Upcase(ObjName[t]);
        end;
        for t:=1 to DirEntries do begin
            for x:=1 to 8 do
                if ObjName[x]='?' then
                    TempName[x]:=DirEntry^[t].ObjName[x]
                else
                    TempName[x]:=ObjName[x];
            if DirEntry^[t].ObjName = TempName then begin
                FindObject:=t;
                exit;
            end;
        end;
        FindObject:=0;
    end;

{Procedure ReadSound(Dir:PWadDir;SoundName:ObjNameStr;var SBuff:PSoundBuff);

    var     l:word;
            TempPtr:PSoundBuff;

    begin
        l:=FindObject(Dir,SoundName);
        if l=0 then begin
            if TerminateOnWadError then begin
                TextMode(co80);
                writeln('ReadSound: Could not locate sound ID: ',SoundName);
                halt(1);
             end
            else begin
                WadResult:=wrNoSound;
                exit;
            end;
        end;
        seek(Dir^.WadFile,Dir^.DirEntry^[l].ObjStart);
        New(TempPtr);}                                    {Allocate New Sound Descriptor}
{        BlockRead(Dir^.WadFile,Dir^.ObjBuffer^[0],Dir^.DirEntry^[l].ObjLength);
        Move(Dir^.ObjBuffer^[2],TempPtr^.SampleRate,4);
        GetMem(TempPtr^.Sound,TempPtr^.Samples);
        Move(Dir^.ObjBuffer^[6],TempPtr^.Sound^,TempPtr^.Samples);
        writeln('Sound Size: ',TempPtr^.Samples);
        SBuff:=TempPtr;
        WadResult:=wrOk;
    end;}

Procedure TWadDirectory.SetWadPalette(PlayPalNum:integer);

    var     Regs:Registers;
            PalEnt:word;
            PBuff:array[1..768] of byte;

    Procedure SaveColor(ColorNum:word);

        begin
            move(OldPalette[ColorNum * 3],PBuff[ColorNum  * 3],3);
        end;

    begin
        if Not WadPaletteIsSet then begin
            with regs do begin
                Regs.ax:=$1017;
                Regs.es:=Seg(OldPalette);
                Regs.dx:=ofs(OldPalette);
                Regs.bx:=0;
                Regs.cx:=256;
                Intr($10,Regs);
            end;
        end;
        PalEnt:=FindObject('PLAYPAL ');
        if PalEnt=0 then begin
            if TerminateOnWadError then begin
                TextMode(CO80);
                writeln('SetWadPalette: Could not locate PLAYPAL');
                halt(1);
             end
            else begin
                WadResult:=wrNoPalette;
                exit;
            end;
        end;
        Seek(WadFile,DirEntry^[PalEnt].ObjStart + (768 * PlayPalNum));
        Blockread(WadFile,Pbuff,768);
        for PalEnt:=1 to 768 do
            Pbuff[PalEnt]:=Pbuff[PalEnt] div 4;
{        SaveColor(7);
        SaveColor(1);
        SaveColor(2);
        SaveColor(3);
        SaveColor(15);
        SaveColor(8);}
        with regs do begin
            ax:=$1012;
            bx:=0;
            cx:=256;
            es:=seg(PBuff);
            dx:=ofs(PBuff);
            Intr($10,Regs);
        end;
        WadResult:=wrOk;
        WadPaletteIsSet:=True;
    end;

Procedure TWadDirectory.RestorePalette;

    var    Regs:Registers;

    begin
        if WadPaletteIsSet then begin
            with regs do begin
                ax:=$1012;
                bx:=0;
                cx:=256;
                es:=seg(OldPalette);
                dx:=ofs(OldPalette);
                Intr($10,Regs);
            end;
        end;
        WadPaletteIsSet:=False;
    end;

{$I-}
Constructor TWadDirectory.Init(WadFileName:String);

    var    DirSize:longint;

    begin
        if ShowInit then
            writeln('W_Init: Initializing WAD file');
        assign(WadFile,WadFileName);
        reset(WadFile,1);
        if IOResult<>0 then begin
            if TerminateOnWadError then begin
                TextMode(CO80);
                writeln('WadDirectory_Init: Error Reading WAD FILE: ',WadFileName);
                halt(1);
             end
            else begin
                WadResult:=wrNoFile;
                exit;
            end;
        end;
        WadFileName:=WadFileName+#0;
        FillChar(WadName,8,#0);
        filesplit(@WadFileName,NIL,@WadName,NIL);
        blockread(WadFile,WadID,12);
        if (WadID<>'IWAD') and (WadID<>'PWAD') then begin
            if TerminateOnWadError then begin
                TextMode(CO80);
                Close(WadFile);
                writeln('W_Init: ',WadFileName,' is not a valid WAD file');
                halt(1);
             end
            else begin
                WadResult:=wrInvalidFile;
                exit;
            end;
        end;
        if DirEntries > MaxEntries then begin
            if TerminateOnWadError then begin
                TextMode(CO80);
                Close(WadFile);
                write('   W_Init_Alloc: Can not allocate for more than ',MaxEntries);
                writeln(' Directory Entries');
                halt(1);
             end
            else begin
                WadResult:=wrMaxEntries;
                exit;
            end;
        end;
        DirSize:=DirEntries * 16;
        GetMem(DirEntry, DirSize);
        FillChar(DirEntry^,DirSize,#00);
        if ShowInit then
            writeln('   W_Init_Alloc: ',DirSize,' Allocated for directory');
        seek(WadFile, DirStart);
        BlockRead(WadFile, DirEntry^, DirSize);
        WadResult:=wrOk;
    end;

Procedure TWadDirectory.DisplayWadDir;

    var    x:word;

    begin
        writeln('Directory of WAD: ',WadName);
        for x:=1 to DirEntries do begin
            with DirEntry^[x] do begin
                writeln(ObjName,'         ',ObjStart,'          ',ObjLength);
            end;
        end;
    end;

Destructor TWadDirectory.Done;

    var    DirSize:word;

    begin
        close(WadFile);
        DirSize:=DirEntries * 16;
        FreeMem(DirEntry, DirSize);
    end;

Function WadResultMsg(ErrNum:byte):string;

    begin
        case ErrNum of
            wrOk:WadResultMsg:='';
            wrInvalidFile:WadResultMsg:='Invalid WAD file Format';
            wrMaxEntries:WadResultMsg:='Too many WAD directory Entries';
            wrNoObject:WadResultMsg:='Specified WAD Object Not Found';
            wrNoSound:WadResultMsg:='Specified WAD Sound Not Found';
            wrBadImageSize:WadResultMsg:='Invalid WAD Image Size';
            wrNoPicture:WadResultMsg:='Specified Picture ID Not Found';
            wrNoPalette:WadResultMsg:='PLAYPAL Entry Not Found';
            wrNoFile:WadResultMsg:='Error Accessing WAD File';
        else
            WadResultMsg:='Unknown WAD file Error'
        end;
    end;

begin
{$IFDEF DFE}
    TextAttr:=7;
    ClrScr;
    TextAttr:=31;
    write('                          The DOOM Hacker''s Tool Kit                            ');
    TextAttr:=7;
    writeln('Sys_Init: Examining System');
    case Test8086 of
        00:begin
                writeln('   CPU_Check: 8088 or 8086');
                writeln('                 This Program requires at least an 80386.');
                halt(1);
            end;
        01:begin
                writeln('   CPU_Check: 80286');
                writeln('                 This Program requires at least an 80386.');
                halt(1);
                end;
        02:begin
                writeln('   CPU_Check: 80386 or better');
            end;
    end;
    delay(450);
    writeln('SysMem_Init: Initializing Memory Allocation Deamon...');
    writeln('   SysMem_Init: ',Hex_String(MaxAvail),'  ');
    if MaxAvail < 300000 then begin
        writeln('   SysMem_Init: Insufficient System Memory!');
        halt(1);
    end;
    delay(500);
{$ELSE}
    writeln;
   writeln('The DOOM Hacker''s Tool Kit v1.00');
   writeln;
   writeln('by: Jackson Software');
   writeln('author: Joshua Jackson      internet: [e-mail]');
    delay(1000);
{$ENDIF}
end.